home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS13.ADF / AmigaBasicProgs / LibDemos / SaveILBM (.txt) < prev    next >
AmigaBASIC Source Code  |  1986-08-05  |  9KB  |  354 lines
  1. REM - SaveILBM
  2. REM -  by Carolyn Scheppner  CBM  04/86
  3.  
  4. REM - This program saves a demo custom
  5. REM -  screen as an IFF ILBM file.
  6. REM -  (Graphicraft,Deluxe Paint, etc.)
  7.  
  8. REM - No icon is created for the file.
  9. REM -  If you need one, copy the .info
  10. REM -  file of a Graphicraft pic and
  11. REM -  call it filename.info
  12.  
  13. REM - Color cycling variables are
  14. REM -  saved as a Graphicraft CCRT
  15. REM -  chunk.  The program could be
  16. REM -  modified to save color cycling
  17. REM -  information as DPaint CRNG
  18. REM -  chunks.
  19.  
  20. REM - Requires exec, graphics and dos
  21. REM -  .bmaps (Use NewConvertFD)
  22. REM
  23.  
  24. Main:
  25.  
  26. PRINT "SaveILBM --- Saves a screen as an IFF ILBM file"
  27. PRINT 
  28. PRINT " This program creates a demo screen and saves it as an"
  29. PRINT "IFF ILBM pic file which can be loaded in Graphicraft,"
  30. PRINT "DPaint, or Images.  (For Images, add '.pic' to filename)"
  31. PRINT
  32. PRINT " Color cycling data is saved as a Graphicraft CCRT chunk."
  33. PRINT "No icon is created for the save file.  If you need one,"
  34. PRINT "copy the .info file of one of your paint package's pics"
  35. PRINT "and rename it to match the name of your saved pic file."
  36. PRINT:PRINT
  37. PRINT:PRINT "ENTER FILESPEC:"
  38. PRINT "( Try Screen.ILBM )"
  39. PRINT "( Enter <RETURN> for NO save file )"
  40. PRINT
  41. INPUT "FileSpec for ILBM save file";ILBMname$
  42. PRINT
  43.  
  44.  
  45. DIM bPlane&(5), cTabSave%(32)
  46.  
  47. REM - Functions from dos.library                   
  48. DECLARE FUNCTION xOpen&  LIBRARY
  49. DECLARE FUNCTION xRead&  LIBRARY
  50. DECLARE FUNCTION xWrite& LIBRARY
  51. DECLARE FUNCTION IoErr&  LIBRARY
  52. REM - xClose returns no value
  53.  
  54. REM - Functions from exec.library
  55. DECLARE FUNCTION AllocMem&() LIBRARY
  56. REM - FreeMem returns no value
  57.  
  58. PRINT:PRINT "Looking for bmaps ... ";
  59. LIBRARY "dos.library"
  60. LIBRARY "exec.library"
  61. LIBRARY "graphics.library"
  62. PRINT "found them."
  63.  
  64. REM  Custom Screen, some graphics
  65. w = 320: h = 200: d = 5
  66.  
  67. AvailRam& = FRE(-1)
  68. NeededRam& = ((w/8)*h*(d+1))+5000
  69. IF AvailRam& < NeededRam& THEN
  70.    PRINT "Not enough free ram"
  71.    GOTO Mcleanup2
  72. END IF   
  73.  
  74. SCREEN 2,w,h,d,1
  75. t$=" SaveILBM"
  76. WINDOW 2,t$,,15,2
  77. PALETTE 0,1,1,1
  78. PALETTE 1,0.2,0.4,0.8
  79.  
  80. REM - Get Screen structure addresses
  81. GOSUB GetScrAddrs
  82.  
  83. REM - Init color cycling variables
  84. REM - (Init to 0 for no cycling)
  85. REM - These variables must be initialized
  86. REM - because this version of SaveILBM
  87. REM - always saves a Graphicraft CCRT chunk
  88. ccrtDir%   = 1
  89. ccrtStart% = 1
  90. ccrtEnd%   = nColors% - 1
  91. ccrtSecs&  = 0
  92. ccrtMics&  = 2000
  93.  
  94. REM - Draw some lines to cycle  
  95. cReg = ccrtStart% 
  96. x = 20 
  97. FOR y = 0 TO 80
  98.      LINE (x,y)-(w-x-10,180-y),cReg,b
  99.      x = x + 1
  100.      cReg = cReg + 1: IF cReg > ccrtEnd% THEN cReg = ccrtStart%
  101. NEXT
  102.  
  103. REM - Demo color cycling
  104. REM - Save colors
  105. FOR kk = 0 TO nColors% -1
  106.    cTabSave%(kk) = PEEKW(colorTab&+(kk*2))   
  107. NEXT
  108.    
  109. REM - Cycle colors
  110. deSecs& = ccrtSecs& * 3000
  111. deMics& = ccrtMics& / 500
  112. cStart& = colorTab& + (2*ccrtStart%)
  113. cEnd&   = colorTab& + (2*ccrtEnd%)
  114. repeat  = 80
  115.  
  116. IF ccrtDir% = 1 THEN GOSUB Fcycle :ELSE GOSUB Bcycle
  117.  
  118. REM - Restore colors
  119. CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%)
  120.  
  121.  
  122. REM - Save screen as ILBM file
  123. IF (ILBMname$<>"") THEN
  124.    saveError$ = ""
  125.    GOSUB SaveILBM
  126. END IF
  127.  
  128. Mcleanup:
  129. FOR de = 1 TO 5000:NEXT
  130. WINDOW CLOSE 2
  131. SCREEN CLOSE 2
  132.  
  133. Mcleanup2:
  134. LIBRARY CLOSE
  135. IF saveError$ <> "" THEN PRINT saveError$
  136. END
  137.  
  138.  
  139. Fcycle:
  140. FOR kk = 0 TO repeat
  141.    cTemp% = PEEKW(cStart&)
  142.    FOR jj& = cStart& + 2 TO cEnd& STEP 2
  143.       POKEW(jj&-2), PEEKW(jj&)
  144.    NEXT
  145.    POKEW cEnd&, cTemp%
  146.    CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
  147.    FOR d1& = 0 TO deSecs&
  148.       FOR d2& = 0 TO deMics&:NEXT
  149.    NEXT   
  150. NEXT
  151. RETURN
  152.  
  153. Bcycle:   
  154. FOR kk = 0 TO repeat   
  155.    cTemp% = PEEKW(cEnd&)
  156.    FOR jj& = cEnd& - 2 TO cStart& STEP -2
  157.       POKEW(jj&+2), PEEKW(jj&)
  158.    NEXT
  159.    POKEW(cStart&) = cTemp%
  160.    CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
  161.    FOR d1& = 0 TO deSecs&
  162.       FOR d2& = 0 TO deMics&:NEXT
  163.    NEXT   
  164. NEXT
  165. RETURN
  166.  
  167.  
  168. SaveILBM:
  169. REM - Saves current window's screen
  170. REM -  as an IFF ILBM file with a
  171. REM -  Graphicraft CCRT cycling chunk.
  172. REM - Requires the following variables
  173. REM -  to have been initialized:
  174. REM -    ILBMname$ (ILBM filespec)
  175. REM - Also, cycling variables
  176. REM -    ccrtDir% (1,-1, or 0 = none)
  177. REM -    ccrtStart% (low cycle reg)
  178. REM -    ccrtEnd%   (high cycle reg)
  179. REM -    ccrtSecs&  (cycle time in seconds)
  180. REM -    ccrtMics&  (cycle time in microseconds)
  181. REM 
  182.  
  183.  
  184. REM - init variables
  185. f$ = ILBMname$
  186. fHandle& = 0
  187. mybuf& = 0
  188.  
  189. filename$ = f$ + CHR$(0)
  190. fHandle& = xOpen&(SADD(filename$),1006)
  191. IF fHandle& = 0 THEN
  192.    saveError$ = "Can't open output file"
  193.    GOTO Scleanup
  194. END IF
  195.  
  196. REM - Alloc ram for work buffers
  197. ClearPublic& = 65537
  198. mybufsize& = 120
  199. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  200. IF mybuf& = 0 THEN
  201.    saveError$ = "Can't alloc buffer"
  202.    GOTO Scleanup
  203. END IF
  204.  
  205. cbuf& = mybuf&
  206.  
  207. REM - Get addresses of screen structures
  208. GOSUB GetScrAddrs
  209.  
  210. zero& = 0
  211. pad%  = 0
  212. aspect% = &Ha0b
  213.  
  214. REM - Compute chunk sizes
  215. BMHDsize& = 20
  216. CMAPsize& = (2^scrDepth%) * 3
  217. CAMGsize& = 4
  218. CCRTsize& = 14
  219. BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
  220. REM - FORMsize& = Chunk sizes + 8 bytes per Chunk header + "ILBM"
  221. FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
  222.  
  223. REM - Write FORM header
  224. tt$ = "FORM"
  225. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  226. wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
  227. tt$ = "ILBM"
  228. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  229.  
  230. IF wLen& <= 0 THEN
  231.    saveError$ = "Error writing FORM header"
  232.    GOTO Scleanup
  233. END IF   
  234.  
  235. REM - Write out BMHD chunk
  236. tt$ = "BMHD"
  237. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  238. wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
  239. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  240. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  241. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  242. temp% = (256 * scrDepth%)
  243. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  244. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  245. wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
  246. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  247. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  248.  
  249. IF wLen& <= 0 THEN
  250.    saveError$ = "Error writing BMHD"
  251.    GOTO Scleanup
  252. END IF   
  253.  
  254. REM - Write CMAP chunk
  255. tt$ = "CMAP"
  256. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  257. wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
  258.  
  259. REM - Build IFF ColorMap
  260. FOR kk = 0 TO nColors% - 1
  261.    regTemp% = PEEKW(colorTab& + (2*kk))
  262.    POKE(cbuf&+(kk*3)),(regTemp% AND &Hf00) / 16
  263.    POKE(cbuf&+(kk*3)+1),(regTemp% AND &Hf0) 
  264.    POKE(cbuf&+(kk*3)+2),(regTemp% AND &Hf) * 16
  265. NEXT
  266.  
  267. wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
  268.  
  269. IF wLen& <= 0 THEN
  270.    saveError$ = "Error writing CMAP"
  271.    GOTO Scleanup
  272. END IF   
  273.  
  274. REM - Write CAMG chunk
  275. tt$ = "CAMG"
  276. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  277. wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
  278. vpModes& = PEEKW(sViewPort& + 32)
  279. wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
  280.  
  281. IF wLen& <= 0 THEN
  282.    saveError$ = "Error writing CAMG"
  283.    GOTO Scleanup
  284. END IF   
  285.  
  286.  
  287. REM - Write CCRT chunk
  288. tt$ = "CCRT"
  289. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  290. wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
  291. wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
  292. temp% = (256*ccrtStart%) + ccrtEnd%
  293. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  294. wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
  295. wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
  296. wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
  297.  
  298. IF wLen& <= 0 THEN
  299.    saveError$ = "Error writing CCRT"
  300.    GOTO Scleanup
  301. END IF   
  302.  
  303.  
  304. REM - Write BODY chunk
  305. tt$ = "BODY"
  306. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  307. wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
  308.  
  309. scrRowBytes% = scrWidth% / 8
  310. FOR rr = 0 TO scrHeight% -1
  311.    FOR pp = 0 TO scrDepth% -1
  312.       scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  313.       wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)   
  314.       IF wLen& <= 0 THEN
  315.          saveError$ = "Error writing BODY"
  316.          GOTO Scleanup
  317.       END IF   
  318.    NEXT
  319. NEXT
  320.  
  321.    
  322. saveError$ = ""
  323.  
  324. Scleanup:
  325. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  326. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  327. RETURN
  328.  
  329.  
  330.  
  331. GetScrAddrs:
  332. REM - Get addresses of screen structures
  333.    sWindow&   = WINDOW(7)
  334.    sScreen&   = PEEKL(sWindow& + 46)
  335.    sViewPort& = sScreen& + 44
  336.    sRastPort& = sScreen& + 84
  337.    sColorMap& = PEEKL(sViewPort& + 4)
  338.    colorTab&  = PEEKL(sColorMap& + 4)
  339.    sBitMap&   = PEEKL(sRastPort& + 4)
  340.  
  341.    REM - Get screen parameters
  342.    scrWidth%  = PEEKW(sScreen& + 12)
  343.    scrHeight% = PEEKW(sScreen& + 14)
  344.    scrDepth%  = PEEK(sBitMap& + 5)
  345.    nColors%   = 2^scrDepth%
  346.  
  347.    REM - Get addresses of Bit Planes 
  348.    FOR kk = 0 TO scrDepth% - 1
  349.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  350.    NEXT
  351. RETURN
  352.  
  353.  
  354.